home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / progs / prelude / PreludeText.hs < prev    next >
Encoding:
Text File  |  1994-09-27  |  8.7 KB  |  261 lines  |  [TEXT/YHS2]
  1. module    PreludeText (
  2.     reads, shows, show, read, lex,
  3.     showChar, showString, readParen, showParen, readLitChar, showLitChar,
  4.     readSigned, showSigned, readDec, showInt, readFloat, showFloat ) where
  5.  
  6. {-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
  7.  
  8. reads             :: (Text a) => ReadS a
  9. reads        =  readsPrec 0
  10.  
  11. shows             :: (Text a) => a -> ShowS
  12. shows        =  showsPrec 0
  13.  
  14. read             :: (Text a) => String -> a
  15. read s             =  case [x | (x,t) <- reads s, ("","") <- lex t] of
  16.             [x] -> x
  17.             []  -> error "read{PreludeText}: no parse"
  18.             _   -> error "read{PreludeText}: ambiguous parse"
  19.  
  20. show             :: (Text a) => a -> String
  21. show x             =  shows x ""
  22.  
  23. showChar        :: Char -> ShowS
  24. showChar        =  (:)
  25.  
  26. showString      :: String -> ShowS
  27. showString      =  (++)
  28.  
  29. showParen       :: Bool -> ShowS -> ShowS
  30. showParen b p     =  if b then showChar '(' . p . showChar ')' else p
  31.  
  32. readParen       :: Bool -> ReadS a -> ReadS a
  33. readParen b g    =  if b then mandatory else optional
  34.            where optional r  = g r ++ mandatory r
  35.              mandatory r = [(x,u) | ("(",s) <- lex r,
  36.                         (x,t)   <- optional s,
  37.                         (")",u) <- lex t    ]
  38.  
  39. lex                 :: ReadS String
  40. lex ""            = [("","")]
  41. lex (c:s) | isSpace c    = lex (dropWhile isSpace s)
  42. lex ('-':'-':s)        = case dropWhile (/= '\n') s of
  43.                  '\n':t -> lex t
  44.                  _    -> [] -- unterminated end-of-line
  45.                           -- comment
  46.  
  47. lex ('{':'-':s)        = lexNest lex s
  48.               where
  49.               lexNest f ('-':'}':s) = f s
  50.               lexNest f ('{':'-':s) = lexNest (lexNest f) s
  51.               lexNest f (c:s)          = lexNest f s
  52.               lexNest _ ""        = [] -- unterminated
  53.                              -- nested comment
  54.  
  55. lex ('<':'-':s)        = [("<-",s)]
  56. lex ('\'':s)        = [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,
  57.                            ch /= "'"        ]
  58. lex ('"':s)        = [('"':str, t)      | (str,t) <- lexString s]
  59.               where
  60.               lexString ('"':s) = [("\"",s)]
  61.               lexString s = [(ch++str, u)
  62.                         | (ch,t)  <- lexStrItem s,
  63.                           (str,u) <- lexString t  ]
  64.  
  65.               lexStrItem ('\\':'&':s) = [("\\&",s)]
  66.               lexStrItem ('\\':c:s) | isSpace c
  67.                   = [("\\&",t) | '\\':t <- [dropWhile isSpace s]]
  68.               lexStrItem s          = lexLitChar s
  69.  
  70. lex (c:s) | isSingle c    = [([c],s)]
  71.       | isSym1 c    = [(c:sym,t)         | (sym,t) <- [span isSym s]]
  72.       | isAlpha c    = [(c:nam,t)         | (nam,t) <- [span isIdChar s]]
  73.       | isDigit c    = [(c:ds++fe,t)         | (ds,s)  <- [span isDigit s],
  74.                            (fe,t)  <- lexFracExp s       ]
  75.       | otherwise    = []    -- bad character
  76.         where
  77.         isSingle c  =  c `elem` ",;()[]{}_"
  78.         isSym1 c    =  c `elem` "-~" || isSym c
  79.         isSym c        =  c `elem` "!@#$%&*+./<=>?\\^|:"
  80.         isIdChar c  =  isAlphanum c || c `elem` "_'"
  81.  
  82.         lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
  83.                               (e,u)  <- lexExp t    ]
  84.         lexFracExp s       = [("",s)]
  85.  
  86.         lexExp (e:s) | e `elem` "eE"
  87.              = [(e:c:ds,u) | (c:t)    <- [s], c `elem` "+-",
  88.                            (ds,u) <- lexDigits t] ++
  89.                [(e:ds,t)   | (ds,t)    <- lexDigits s]
  90.         lexExp s = [("",s)]
  91.  
  92. lexDigits        :: ReadS String    
  93. lexDigits        =  nonnull isDigit
  94.  
  95. nonnull            :: (Char -> Bool) -> ReadS String
  96. nonnull p s        =  [(cs,t) | (cs@(_:_),t) <- [span p s]]
  97.  
  98. lexLitChar        :: ReadS String
  99. lexLitChar ('\\':s)    =  [('\\':esc, t) | (esc,t) <- lexEsc s]
  100.     where
  101.     lexEsc (c:s)     | c `elem` "abfnrtv\\\"'" = [([c],s)]
  102.     lexEsc ('^':c:s) | c >= '@' && c <= '_'  = [(['^',c],s)]
  103.     lexEsc s@(d:_)     | isDigit d         = lexDigits s
  104.     lexEsc ('o':s)    =  [('o':os, t) | (os,t) <- nonnull isOctDigit s]
  105.     lexEsc ('x':s)    =  [('x':xs, t) | (xs,t) <- nonnull isHexDigit s]
  106.     lexEsc s@(c:_)     | isUpper c
  107.             =  case [(mne,s') | mne <- "DEL" : elems asciiTab,
  108.                         ([],s') <- [match mne s]      ]
  109.                of (pr:_) -> [pr]
  110.                   []     -> []
  111.     lexEsc _    =  []
  112. lexLitChar (c:s)    =  [([c],s)]
  113. lexLitChar ""        =  []
  114.  
  115. isOctDigit c  =  c >= '0' && c <= '7'
  116. isHexDigit c  =  isDigit c || c >= 'A' && c <= 'F'
  117.                || c >= 'a' && c <= 'f'
  118.  
  119. match            :: (Eq a) => [a] -> [a] -> ([a],[a])
  120. match (x:xs) (y:ys) | x == y  =  match xs ys
  121. match xs     ys              =  (xs,ys)
  122.  
  123. asciiTab = listArray ('\NUL', ' ')
  124.        ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
  125.         "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI", 
  126.         "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
  127.         "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US", 
  128.         "SP"] 
  129.  
  130.  
  131.  
  132. readLitChar         :: ReadS Char
  133. readLitChar ('\\':s)    =  readEsc s
  134.     where
  135.     readEsc ('a':s)     = [('\a',s)]
  136.     readEsc ('b':s)     = [('\b',s)]
  137.     readEsc ('f':s)     = [('\f',s)]
  138.     readEsc ('n':s)     = [('\n',s)]
  139.     readEsc ('r':s)     = [('\r',s)]
  140.     readEsc ('t':s)     = [('\t',s)]
  141.     readEsc ('v':s)     = [('\v',s)]
  142.     readEsc ('\\':s) = [('\\',s)]
  143.     readEsc ('"':s)     = [('"',s)]
  144.     readEsc ('\'':s) = [('\'',s)]
  145.     readEsc ('^':c:s) | c >= '@' && c <= '_'
  146.              = [(chr (ord c - ord '@'), s)]
  147.     readEsc s@(d:_) | isDigit d
  148.              = [(chr n, t) | (n,t) <- readDec s]
  149.     readEsc ('o':s)  = [(chr n, t) | (n,t) <- readOct s]
  150.     readEsc ('x':s)     = [(chr n, t) | (n,t) <- readHex s]
  151.     readEsc s@(c:_) | isUpper c
  152.              = let table = ('\DEL',"DEL") : assocs asciiTab
  153.                in case [(c,s') | (c,mne) <- table,
  154.                          ([],s') <- [match mne s]]
  155.                   of (pr:_) -> [pr]
  156.                  []    -> []
  157.     readEsc _     = []
  158. readLitChar (c:s)    =  [(c,s)]
  159.  
  160. showLitChar            :: Char -> ShowS
  161. showLitChar c | c > '\DEL' =  showChar '\\' . protectEsc isDigit (shows (ord c))
  162. showLitChar '\DEL'       =  showString "\\DEL"
  163. showLitChar '\\'       =  showString "\\\\"
  164. showLitChar c | c >= ' '   =  showChar c
  165. showLitChar '\a'       =  showString "\\a"
  166. showLitChar '\b'       =  showString "\\b"
  167. showLitChar '\f'       =  showString "\\f"
  168. showLitChar '\n'       =  showString "\\n"
  169. showLitChar '\r'       =  showString "\\r"
  170. showLitChar '\t'       =  showString "\\t"
  171. showLitChar '\v'       =  showString "\\v"
  172. showLitChar '\SO'       =  protectEsc (== 'H') (showString "\\SO")
  173. showLitChar c           =  showString ('\\' : asciiTab!c)
  174.  
  175. protectEsc p f           = f . cont
  176.                  where cont s@(c:_) | p c = "\\&" ++ s
  177.                    cont s          = s
  178.  
  179. readDec, readOct, readHex :: (Integral a) => ReadS a
  180. readDec = readInt 10 isDigit (\d -> ord d - ord '0')
  181. readOct = readInt  8 isOctDigit (\d -> ord d - ord '0')
  182. readHex = readInt 16 isHexDigit hex
  183.         where hex d = ord d - (if isDigit d then ord '0'
  184.                    else ord (if isUpper d then 'A' else 'a')
  185.                     - 10)
  186.  
  187. readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
  188. readInt radix isDig digToInt s =
  189.     [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
  190.     | (ds,r) <- nonnull isDig s ]
  191.  
  192. showInt    :: (Integral a) => a -> ShowS
  193. showInt n r = let (n',d) = quotRem n 10
  194.           r' = chr (ord '0' + fromIntegral d) : r
  195.           in if n' == 0 then r' else showInt n' r'
  196.  
  197. readSigned:: (Real a) => ReadS a -> ReadS a
  198. readSigned readPos = readParen False read'
  199.              where read' r  = read'' r ++
  200.                       [(-x,t) | ("-",s) <- lex r,
  201.                         (x,t)   <- read'' s]
  202.                read'' r = [(n,s)  | (str,s) <- lex r,
  203.                               (n,"")  <- readPos str]
  204.  
  205. showSigned:: (Real a) => (a -> ShowS) -> Int -> a -> ShowS
  206. showSigned showPos p x = if x < 0 then showParen (p > 6)
  207.                          (showChar '-' . showPos (-x))
  208.                   else showPos x
  209.  
  210.  
  211. -- The functions readFloat and showFloat below use rational arithmetic
  212. -- to insure correct conversion between the floating-point radix and
  213. -- decimal.  It is often possible to use a higher-precision floating-
  214. -- point type to obtain the same results.
  215.  
  216. readFloat:: (RealFloat a) => ReadS a
  217. readFloat r = [(fromRational ((n%1)*10^^(k-d)), t) | (n,d,s) <- readFix r,
  218.                              (k,t)   <- readExp s]
  219.               where readFix r = [(read (ds++ds'), length ds', t)
  220.                     | (ds,'.':s) <- lexDigits r,
  221.                       (ds',t)    <- lexDigits s ]
  222.  
  223.             readExp (e:s) | e `elem` "eE" = readExp' s
  224.                     readExp s              = [(0,s)]
  225.  
  226.                     readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
  227.                     readExp' ('+':s) = readDec s
  228.                     readExp' s         = readDec s
  229.  
  230. -- The number of decimal digits m below is chosen to guarantee 
  231. -- read (show x) == x.  See
  232. --    Matula, D. W.  A formalization of floating-point numeric base
  233. --    conversion.  IEEE Transactions on Computers C-19, 8 (1970 August),
  234. --    681-692.
  235.  
  236. showFloat:: (RealFloat a) => a -> ShowS
  237. showFloat x =
  238.     if x == 0 then showString ("0." ++ take (m-1) (repeat '0'))
  239.           else if e >= m-1 || e < 0 then showSci else showFix
  240.     where
  241.     showFix    = showString whole . showChar '.' . showString frac
  242.           where (whole,frac) = splitAt (e+1) (show sig)
  243.     showSci    = showChar d . showChar '.' . showString frac
  244.               . showChar 'e' . shows e
  245.               where (d:frac) = show sig
  246.     (m, sig, e) = if b == 10 then (w,      s,   n+w-1)
  247.                    else (m', sig', e'   )
  248.     m'        = ceiling
  249.               (fromIntegral w * log (fromInteger b) / log 10 :: Double)
  250.           + 1
  251.     (sig', e')    = if      sig1 >= 10^m'     then (round (t/10), e1+1)
  252.           else if sig1 <  10^(m'-1) then (round (t*10), e1-1)
  253.                           else (sig1,        e1  )
  254.     sig1 :: Integer
  255.     sig1    = round t
  256.     t        = s%1 * (b%1)^^n * 10^^(m'-e1-1)
  257.     e1        = floor (logBase 10 x)
  258.     (s, n)    = decodeFloat x
  259.     b        = floatRadix x
  260.     w        = floatDigits x
  261.